#!/usr/bin/perl

# Jabber-presence-bot
# Copyright (C) 2009 web-apps.ru
# 
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

# xmpp:web-apps@jabber.ru

BEGIN {
	# пытаемся сменить текущую директорию на ту, где скрипт непосредственно расположен
	$0 =~ /^.*[\/\\]/;
	chdir $&;
	# "отрываемся" от терминала
	unless (grep { $_ eq '--no-fork' } @ARGV) {
		exit if fork;
	}
}

use strict;
use utf8;
use Digest::SHA1 qw(sha1_base64);

use lib '../';
use lib '../lib/';

require Custom;
my $custom=Custom->new;

# на сервере стоит довольно старенькая версия perl, там эта строка нужна
eval 'use encoding "utf8"';

binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");

# запоминаем время начала работы
my $startTime=time;
# версия бота
my $VERSION=0.48;

my $IDENTIFY={ category => 'client', type => 'bot', name => "Web-Apps-Jabber-Presence-bot v$VERSION" };
my @FUTURES=qw(
	http://jabber.org/protocol/pubsub#auto-subscribe
	http://jabber.org/protocol/commands
	http://jabber.org/protocol/caps
	http://jabber.org/protocol/disco#info
	http://jabber.org/protocol/tune
	http://jabber.org/protocol/tune+notify
	http://jabber.org/protocol/mood
	http://jabber.org/protocol/mood+notify
	http://jabber.org/protocol/chatstates
);

my $v=sha1_base64(
	join '',
		(
			map { $_ . '<' }
				join('/', map { $IDENTIFY->{$_} } qw/category type lang name/),
				sort { $a cmp $b } @FUTURES,
		),
) . '=';

#проверяем нет ли уже запущенного бота (запрос из БД),
#если нет - заносим свои данные
do {
	require Model::Bots;
	my $bot= Model::Bots->new('web-apps-presence');
	#если задан ключ --kill, то "убиваем" запущенную копию бота (если она имеется)
	do { $bot->kill_exists; sleep 1 } if defined $ARGV[0] and $ARGV[0] eq '--kill';
	# внутри ->Alone идёт проверка: есть ли в таблице Bots уже запись c идентификатором
	# web-apps-presence, если таковая найдётся, берётся PID и проверяется жив ли еще процесс с
	# таким PID-ом, если жив, то происходит выход из текущего процесса.
	# Таким образом, вторая копия этого же бота не запустится.
	# Если же таковой записи в таблице нет, то она добавляется (включая текущий PID)
	$bot->Alone();
};

# получение данных их файла настроек
my $CONF=do('conf/jb.conf') or die('Похоже, что файла настроек не существует или с ним что-то не так!');

require Net::XMPP;
require Net::XMPP::Client;
require Net::XMPP::IQ;

# загрузка ORM-моделей, представляющих собой обёртку над данными в БД
require Model::Presence_for_bot;
require Model::Presence_config_for_bot;
require Model::Presence_media;

# Model::Presence_for_bot (к примеру) это обёртка над Model::Presence
# зачем это надо? Для добавления функций, которые нужны только боту.
# Конкретно - добавляется функция подсчёта количества запросов к БД (по типам - update, select, insert)
# (статистика потом выводится ботом)

do {
	# очищаем таблицу статусов
	my $p= Model::Presence_for_bot->new;
	if ($p->type eq 'mysql') {
		# если тип таблицы mysql, то TRUNCATE-им её
		$p->query(
			sprintf('TRUNCATE TABLE %s',
				$p->qi($p->tablename)
			)
		);
	} else {
		# иначе универсальный вариант - делаем DELETE всех записей
		$p->delete();
	}
};

my $client = new Net::XMPP::Client( debuglevel => $CONF->{debuglevel} );

$client->AddNamespace(
	ns => 'http://jabber.org/protocol/pubsub#event',
	tag => 'event',
	xpath => {
		Items => {
			calls => [ 'Get' ],
			path => 'items/item',
			type => 'child',
			child => { ns => '__netxmpp__:pubsub:tune' },
		},
		MoodItems => {
			calls => [ 'Get' ],
			path => 'items[@node="http://jabber.org/protocol/mood"]/item',
			type => 'child',
			child => { ns => '__netxmpp__:pubsub:mood' },
		}
	}
);

$client->AddNamespace(
	ns => 'http://jabber.org/protocol/tune',
	tag => 'tune',
	xpath => {
		map {
			$_ => {
				calls => [ 'Get' ],
				path => lc($_) . '/text()'
			}
		} qw/Artist Title Source Track Length/
	}
);

$client->AddNamespace(
	ns => 'http://jabber.org/protocol/mood',
	tag => 'mood',
	xpath => {
		Text => {
			calls => [ 'Get' ],
			path => 'text/text()',
		}
	}
);

# <!-- ставим обработчики

$client->SetCallBacks(
	onauth => \&onAuth,
);

$client->SetMessageCallBacks(
	#normal=>\&messageNormalCB,
	chat=>\&on_message
);

$client->SetPresenceCallBacks(
	available => \&statusChange,
	unavailable => \&statusChange,
	subscribed => \&subscribed,
	unsubscribed => \&unsubscribed,
);

$client->SetIQCallBacks(
	'vcard-temp' => {
		result       => \&on_vcard_result,
	},
	'jabber:iq:version' => {
		result => \&on_version_result,
		get => \&on_version_request,
	},
	'http://jabber.org/protocol/disco#info' => {
		result => \&on_futures_result,
		get => \&on_futures_request
	},
);

$client->SetXPathCallBacks(
	'/iq[@type="set"]/command[@node="botstat"]' => \&on_botstat_command,
	'/iq[@type="get"]/query[@node="botstat"]' => \&on_botstat_question,
	'/iq[@type="get"]/query[@node="http://jabber.org/protocol/commands"]' => \&on_commands_list_request,
	'//event/items[@node="http://jabber.org/protocol/tune"]' => \&on_tune_event,
	'//mood' => \&on_mood,
);

# конец установки обработчиков --/>

# узнаём как же нас зовут
my $MY_JID= Net::XMPP::JID->new($CONF->{jabber_id});

# соединяемся с сервером и шлём наше имя (которое мы только что узнали)
$client->Execute(
	hostname=> $CONF->{jabber_server} || $MY_JID->GetServer,
	username=> $MY_JID->GetUserID,
	password=> $CONF->{jabber_password},
	resource=> $MY_JID->GetResource,
	$CONF->{jabber_server} ? ( componentname => $MY_JID->GetServer ) : (),
);

$client->Disconnect();

# процедура ответа (сообщенение шлётся в чат), вызывается из обработчиков
sub reply {
	my $p={ @_ };

	length($p->{message}) and $client->MessageSend(
		to => $p->{sender},
		subject => "",
		body => $p->{message},
		type => 'chat',
		thread => $p->{thread},
	);
}


# ============= обработчики событий ==================

sub onAuth {
	# как только авторизовались - шлём сообщение что мы в сети,
	# здравствуйте, люди добрые!
	my $p=Net::XMPP::Presence->new();

	$p->InsertRawXML(qq|
	<c xmlns='http://jabber.org/protocol/caps'
	     hash='sha-1'
	          node="http://web-apps.ru/jabber-presence/"
		       ver='$v'/> |);
	$p->SetPresence(
		show=> $CONF->{jabber_show},
		priority=> $CONF->{jabber_priority},
		status => $CONF->{jabber_status}
	);
	$client->Send( $p );

	do {
		my %roster = $client->RosterGet;
		map { print $_ . ' => ' .  $roster{$_}->{subscription} . "\n"; } keys %roster;
	} if $CONF->{debug_printroster};
}

sub on_vcard_result {
	# после запроса карточки клиента, обычно приходит результат, обрабатываем его,
	# сохраняем данные в базу данных
	my $iq=$_[1];
	(my $vcard = $iq->GetChild()->GetXML()) =~ s/\n//g;
	
	# извлекаем данные отдельных полей
	# не очень красиво, да, элегантней было бы использовать Xpath, 
	# но это лишняя библиотека, а значит - затраты памяти
	my ($nickname) = ( $vcard=~/<NICKNAME>(.*?)<\/NICKNAME>/ );
	my ($fullname) = ( $vcard=~/<FN>(.*?)<\/FN>/ );
	my ($bday) = ( $vcard=~/<BDAY>(.*?)<\/BDAY>/ );

	my($photo) = ( $vcard=~/<PHOTO>(.*)<\/PHOTO>/ );
	my ($photo_type) = ( $photo=~/<TYPE>(.*?)<\/TYPE>/ );
	my ($photo_value) = ( $photo=~/<BINVAL>(.*?)<\/BINVAL>/ );

	my $p_media=Model::Presence_media->new;
	my $from= $iq->GetFrom('jid');

	# сначала пробуем обновить данные в базе, а если записи с таким 
	# jid в базе нет (update вернёт 0), то создаём её (insert)
	$p_media
		->where(
			jid => $from->GetJID('base'),
		)->set(
			nick => $nickname,
			photo_type => $photo_type,
			photo_value => $photo_value,
		)->update()
	or

	$p_media
		->set(
			jid => $from->GetJID('base'),
			nick => $nickname,
			photo_type => $photo_type,
			photo_value => $photo_value,
		)->insert();
}

sub on_version_request {
	# у нас спросили нашу версию - отвечаем
	my $request_iq=$_[1];
	my $iq = new Net::XMPP::IQ();
	$iq->SetIQ( type => 'result', to=> $request_iq->GetFrom, id => $request_iq->GetID );
	$iq->InsertRawXML(qq{
		<query xmlns="jabber:iq:version">
		<name>jabber-presence-bot</name>
		<version>v$VERSION</version>
		<os>Perl Net::XMPP</os>
		</query>
	});
	$client->Send($iq);
}

sub on_version_result {
	my $iq=$_[1];
	my $result = $iq->GetChild()->GetXML();
	my ($client) = ( $result=~/<name>(.*?)<\/name>/ );
	my ($version) = ( $result=~/<version>(.*?)<\/version>/ );
	my ($os_name) = ( $result=~/<os>(.*?)<\/os>/ );

	my $p=Model::Presence_for_bot->new;
	my $from= $iq->GetFrom('jid');

	$p
		->where(
			jid => $from->GetJID('base'),
			resource => $from->GetResource,
		)->set(
			client_name => $client,
			client_version => $version,
			os_name => $os_name,
		)->update();
}

sub on_futures_request {
	my $request_iq=$_[1];

	my $node=$request_iq->GetChild->GetTree->get_attrib('node');

	my $iq = new Net::XMPP::IQ();
	$iq->SetIQ( type => 'result', to=> $request_iq->GetFrom, id => $request_iq->GetID );
	$iq->InsertRawXML(q{
		<query xmlns="http://jabber.org/protocol/disco#info"} . ( defined $node ? " node='$node'" : '') . q{>
			<identity category="} . $IDENTIFY->{category}
			. q{" type="} . $IDENTIFY->{type} . q{" name="} . $IDENTIFY->{name} . q{" />}
			. join("\n", map { qq(<feature var="$_" />) } @FUTURES)
		. q{</query>}
	);

	$client->Send($iq);
}

sub on_futures_result {
	my $iq=$_[1];
	my $result = $iq->GetChild()->GetXML();
}

sub on_commands_list_request {
	my $request_iq=$_[1];

	my $iq = new Net::XMPP::IQ();
	$iq->SetIQ( type => 'result', to=> $request_iq->GetFrom(), id => $request_iq->GetID );
	$iq->InsertRawXML(q{
		  <query xmlns='http://jabber.org/protocol/disco#items'
			 node='http://jabber.org/protocol/commands'>
		    <item jid='} . $MY_JID->GetJID('full') . q{' node='botstat' name='Статистика работы бота'/>
		  </query>}
	);
	$client->Send($iq);
}

sub on_botstat_question {
	my $request_iq=$_[1];
	my $iq = new Net::XMPP::IQ();
	$iq->SetIQ( type => 'result', to=> $request_iq->GetFrom, id => $request_iq->GetID );

	$iq->InsertRawXML(q{
		<query xmlns="http://jabber.org/protocol/disco#info" node="botstat" >
		<identity category="automation" type="command-node" />
		<feature var="http://jabber.org/protocol/commands" />
		<feature var="jabber:x:data" />
		</query>
	});

	$client->Send($iq);
}

sub on_botstat_command {
	#отправляем статистику работы бота

	my $request_iq=$_[1];

	#my $node= $request_iq->GetChild()->GetAttributes()->{node};
	my $iq = new Net::XMPP::IQ();
	$iq->SetIQ( type => 'result', to=> $request_iq->GetFrom, id => $request_iq->GetID );

	my $p=Model::Presence_for_bot->new;
	my $pc=Model::Presence_config_for_bot->new;

	$iq->InsertRawXML(sprintf q{
		<command xmlns="http://jabber.org/protocol/commands" status="completed">
		<x xmlns="jabber:x:data" type="result" >
		<title>Статистика работы бота</title>
		<field type="fixed">
			<value>В сети с: %s</value>
			<desc>Время начала работы бота (по Москве)</desc>
		</field>
		<field type="fixed" >
			<value>Количество включивших отображение: %d</value>
		</field>
		<field type="fixed">
			<value>Из них на данный момент в сети: %d</value>
		</field>
		<field type="fixed">
			<value>Версия бота: %s</value>
		</field>
		<field type="fixed">
			<value>Запросы к БД (presence): %s</value>
		</field>
		<field type="fixed">
			<value>Запросы к БД (presence_config): %s</value>
		</field>
		<field type="fixed">
			<value>Запросы к БД (presence): %s</value>
		</field>
		<field type="fixed">
			<value>Запросы к БД (presence_config): %s</value>
		</field>
		</x>
		</command>
	},
		scalar localtime $startTime,
		$pc->enabled_count,
		$p->count( distinct => 'jid' ),
		$VERSION,
		join(' / ', map { $_ . ': ' . int $p->new->db_count->{$_} } qw/select update insert/ ),
		join(' / ', map { $_ . ': ' . int $pc->new->db_count->{$_} } qw/select update insert/ ),
		join(' / ', map { $p->db_count->{$_} ? $_ . ': каждые ' . sprintf('%.02f', (time-$startTime) / $p->db_count->{$_} ) . ' сек.' : '?' } qw/select update insert/ ),
		join(' / ', map { $pc->db_count->{$_} ? $_ . ': каждые ' . sprintf('%.02f', (time-$startTime) / $pc->db_count->{$_} ) . ' сек.' : '?' } qw/select update insert/ ),
	);

	$client->Send($iq);
}

sub on_message {
	$custom->on_message(@_);
}

sub on_mood {
	my($sid, $pr)=@_;

	my $p=Model::Presence_for_bot->new;
	my $from= $pr->GetFrom('jid');

	map {
		#dirty!!!
		my @tags = grep { $_ ne 'text' } grep { ! /^_/ } map { $_->{TAG} } @{ $_->{TREE}{CHILDREN} };
		$p
			->where(
				jid => $from->GetJID('base'),
				length $from->GetResource ? ( resource => $from->GetResource ) : (),
			)->set(
				mood => @tags ? $tags[0] : undef,
				mood_text => $_->GetText,
			)->update();
	}
		map { $_->GetChild('http://jabber.org/protocol/mood') } 
			map { $_->GetMoodItems } $pr->GetChild('http://jabber.org/protocol/pubsub#event');
}

sub on_tune_event {
	my($sid, $pr)=@_;

	my $p=Model::Presence_for_bot->new;
	my $from= $pr->GetFrom('jid');

	map {
		$p
			->where(
				jid => $from->GetJID('base'),
				length $from->GetResource ? ( resource => $from->GetResource ) : (),
			)->set(
				tune_artist => $_->GetArtist,
				tune_title => $_->GetTitle,
				tune_source => $_->GetSource,
				tune_track => $_->GetTrack,
				tune_length => 0 + $_->GetLength,
			)->update();
	}
		map { $_->GetChild('http://jabber.org/protocol/tune') }
			map { $_->GetItems } $pr->GetChild('http://jabber.org/protocol/pubsub#event');
}

sub subscribed {
	my ($sid,$pres) = @_;
	my($jid)= ( $pres->GetFrom=~m%^([^\/]+)% );
	my $c=Model::Presence_config_for_bot->new;
	$c->where(jid => $jid)->load();
	$c->set(
		jid => $jid,
		enable => 0,
	)->set_raw(
		$c-> id ? () : ( registered => $c->case_type(mysql => 'NOW()', firebird => 'CURRENT_TIMESTAMP') )
	)->reset_conf->save();

	reply(
		sender => $pres->GetFrom,
		message => 'Здравствуйте, Вы подписаны!'
			. "\n" . 'Обратите внимание, что отображение статуса сейчас не включено.'
			. "\n" . 'Чтобы просмотреть как его включить и возможные команды наберите "помощь" или "help".'
	);
}

# если пользователь удалил бота из ростера,
# отключаем для него отображение ( устанавливаем enable=0 )
sub unsubscribed {
	my ($sid,$pres) = @_;
	my($jid)= ( $pres->GetFrom=~m%^([^\/]+)% );
	Model::Presence_config_for_bot->new->where(jid => $jid)->set( enable => 0 )->update();
}

sub statusChange {
	my ($sid,$pres) = @_;
	my $m=Model::Presence_for_bot->new;
	my $from=$pres->GetFrom('jid');

	my $c=Model::Presence_config_for_bot->new;

	$c
		->what(qw/jid enable/)
		->where(
			jid => $from->GetJID('base'),
		)->load()
	or return;

	(!$pres->DefinedType() or $pres->GetType eq 'available')
			and !$m->showFor($from->GetJID('base')) and do {
		#запрос vcard
		my $iq = new Net::XMPP::IQ();
		$iq->SetIQ( type => 'get', to => $pres->GetFrom );
		$iq->InsertRawXML( q|<vcard xmlns='vcard-temp' />| );
		$client->Send($iq);

		#запрос версии клиента
		$iq = new Net::XMPP::IQ();
		$iq->SetIQ( type => 'get', to=> $pres->GetFrom );
		$iq->InsertRawXML( q|<query xmlns='jabber:iq:version' />| );
		$client->Send($iq);
	};


	$m
		->what(
			$m->id_name,
			'jid'
		)->where(
			jid => $from->GetJID('base'),
			resource => $from->GetResource,
		)->load();
	
	$pres->GetType eq 'unavailable' ? 
			do { $m->id and $m->delete }
		:
			$m->set(
				jid => $from->GetJID('base'),
				resource => $from->GetResource,
				show => $pres->GetShow() || 'online',
				priority => $pres->GetPriority,
				status => $pres->GetStatus,
				type => $pres->GetType,
			)->save()
		;

	presenceAll(
		to => $pres->GetFrom,
		status => $c->{enable} ? 'Статус отображается' : 'Отображение статуса отключено'
	);
}

sub presenceAll {
	my $opt= { @_ };

	my($jid) = ( $opt->{to}=~m%^([^/]+)% );

	return if $jid eq $MY_JID->GetJID('full');

	my $p=Net::XMPP::Presence->new;
	$p->SetPresence(
		to => $jid,
		show => Model::Presence_for_bot->new->showFor( $opt->{to} ),
		status => $opt->{status}
	);
	$p->InsertRawXML(qq|
		<c xmlns='http://jabber.org/protocol/caps' hash='sha-1' node="http://web-apps.ru/jabber-presence/" ver='$v'/> |);
	$client->Send( $p );
}
